perm filename WORDS.OLD[XX,LCS]1 blob
sn#214137 filedate 1976-05-04 generic text, type T, neo UTF8
00100 C WORDS, TYPE, SETLET, SETNUM ,(NEWR,LNEND), FILLMS, PRESCN
00200
00300 SUBROUTINE WORDS
00400 INTEGER PWDS
00500 COMMON R2,JA,RC,J2,R3,R4,R5,R6,R7,X,IA,N
00600 1,Z,J,KN,ISET,KNT,Q(26),JR /PTR/PWDS(250),ITEM,LL,IS,IX
00700 C /SCX/ IS ALSO IN SCMSS, NOTBMS, RHYTH, BEAMS, NEWR(IN LOOP.FAI)
00800 C **** WHEN JALPHA IS EXTENDED FIX LOOP AT 365 AND SUBR. NEWR(IN LOOP)
00900 C **** AND SUBR. SCMSS, NOTBMS, RHYTH AND BEAMS
01000 COMMON/SCX/RHY(4),JALPHA(30),J4,L,Y,K,RX,RZ,RA,J5
01100 1/XRN/RN(4000) /ALF/INP(72),ML
01200 COMMON/SCN/LEL,LR,LU,LD,KSLA,LE,LC,LS,LF,LA,LI,LW
01300 EQUIVALENCE (IBLA,JALPHA(12)),(INP2,INP(2))
01400 DATA JALPHA/',','-','.','=','(',')','+','*',':',';'
01500 1 ,'"',' ','$','%','&','@','#','<','>',1H','?','!'
01600 1 ,"555004020100,"565004020100,"571004020100,"5004020100,
01700 1 "135004020100,0,0,0/
01800 C FOR ENTERING TEXT: 16, POS., STF., NT#., SIZE, RHYTHM≠0
01900 C NOT ANY LONGER****** R6 ≠0 CALLS NOTE NUM. SETUP
02000 JR=-1
02010 KNT=-1
02055 C COUNTER FOR SEPARATE TEXT ITEMS.
02100 CC IF(R3.NE.999)GO TO 131
02150 IF(INP2.NE.LF)GO TO 131
02175 C TYPE 'TF n,n,n,n' TO READ TYPEIN FROM A FILE.
02200 TYPE 331
02300 ACCEPT 631,KN
02400 IF(LOOK(KN).EQ.0)RETURN
02410 R2=R3
02420 R3=R4
02425 R4=R5
02430 R5=R6
02440 C 'TF' PUSHES PARAM LIST ONE NOTCH TO RIGHT.
02500 C GO BACK IF NO FILE FOUND. READS ONLY FILES WITH LINE NUMBERS.
02600 CALL IFILE(21,KN)
02700 READ(21,431)JR,INP
02800 JR=0
02900 CC R6=1
03000 GO TO 531
03100 631 FORMAT(A5)
03200 331 FORMAT(' TYPE FILE NAME-- '$)
03300 431 FORMAT(I,72A1)
03400 131 CALL TYPE
03500 531 DO 31 KN=72,1,-1
03600 31 IF(INP(KN).NE.IBLA)GO TO 33
03700 C KN=NUM OF CHARACTERS
03800 C DON'T END WITH '*' IN 'LETTERS' INPUT!!!!!!!!
03900 C , - . = ( ) + * : ; " BLANK (FONTS) ' --THIS IS ORDER PAST ALPHAB.
04000 C [=QTR NOTE, ]=HALF NOTE, ↑=#, ↓=b, ↔=NATURAL, 3 SLOTS STILL OPEN
04100
04200 C 48 $=UPPER CASE, 49 %=LOWER, 50 &=NON-ITALICS, 51 @=ITALICS
04300 C 48 AND 49 NOT NEEDED NOW 6/75
04400 C 52 #=RETURN TO PRIMITVE FONT, 53 <=OPEN, 54 >=FILLED. ('=55)
04500 33 L=1
04600 RC=0
04700 IF(INP(KN).EQ.KSLA)GO TO 133
04800 KN=KN+1
04900 INP(KN)=KSLA
05000 C SO TRAILING BLANKS ARE DELETED.
05100 133 LL=1
05200 RZ=0
05300 ISET=IS
05400 IF(R3.LT.1000)GO TO 233
05500 RZ=1
05600 R3=R3-1000.
05700 RC=R3
05800 C ADD 1000 TO POSITION (R3+1000) FOR CENTERING AT POS. R3.
05900 233 RA=R3
06000 C RA= ADDS UP TOTAL SPACE NEEDED
06100 RX=0
06200 C FOR SETLET
06300 368 RN(IS+1)=16
06400 RN(IS+3)=RA
06500 C NEXT IS A MAGIC NUMBER FOR SPACING LETTERS.
06600 CC Y=39.6*RSTJ3
06700 C RBL IS FOR CONTROL(NON-LETTERS, ETC.) CHARACTERS.
06800 RN(IS+2)=R2
06900 RN(IS+4)=R4
07000 CALL NOZERO(R5)
07100 RN(IS+5)=R5
07200 IF(R5.GE.100)R5=R5-100
07300 C >100 FOR TEXT IN ORCH SCORES TO GO IN ALL SEP. PARTS.
07400
07500 DO 364 J5=6,8
07600 Z=0
07700 DO 363 J4=1,4
07800 361 IA=INP(L)
07900 IF(IA.NE.KSLA)GO TO 365
08000 C NEG. SPACE IS ENTERED IN P1 FOR EACH "FIRST" ITEM.
08100 J3=J4
08200 DO 367 KA=J5,8
08300 X=99.
08400 DO 366 K=J3,4
08500 Z=Z+X
08600 366 X=X*100.0
08700 RN(IS+KA)=Z
08800 J3=1
08900 367 Z=0
09000 L=L+1
09100 C L=CHARACTER COUNTER
09200 GO TO 369
09300 365 DO 362 J=1,30
09400 IF(IA.NE.JALPHA(J))GO TO 362
09500 N=35+J
09600 C FOUND A SPECIAL CHARACTER.
09700 K=N
09800 IFNT=0
09900 GO TO 39
10000 362 CONTINUE
10100 38 N=10-(LA-INP(L))/536870912
10200 C MAGIC NUMBER TO FIND LETTERS
10300 IF(N.LT.10)N=N+7
10400 K=N
10500 IF(KFNT)IFNT=0
10600 IF(N.LT.40)GO TO 39
10700 N=N+28
10800 KFNT=-1
10900 C TO INITIALIZE AUTOMATIC LOWER CASE SYSTEM.
11000 K=N-60
11100 C K IS ACTUAL LETTER NUMB. (a=10, ETC.)
11200 IFNT=-1
11300 C LOWER CASE LETTERS ARE 60 .GT. UPPER. A=10, a=70, b=71, etc.
11400 39 L=L+1
11500 C BLANK=99(=47)
11600 CALL SPACER(K,IFNT,RX,3.32)
11700 C NUM↑↑=19.7/5.96 FOR BASIC SPACE PER LETTER.
11800 C GET SPACE FOR THIS LETTER.
11900 X=N
12000 IF(J4.EQ.2)X=X*10000.
12100 IF(J4.EQ.3)X=X*100.
12200 IF(J4.EQ.1)X=X*1000000.
12300 363 Z=Z+X
12400 364 RN(IS+J5)=Z
12500 369 RN(IS+9)=RX
12600 RN(IS+10)=RZ
12650 IF(RZ.EQ.0)KNNT=KNT+1
12700 IF(RC.NE.0)RN(IS+10)=RC
12800 RC=0
12900 C FOR CONTINUATION
13000 RA=RA+RX*R5
13100 IF(IA.EQ.KSLA)RA=RA+5
13200 C SPACES GROUPS DIVIDED BY SLASHES
13300 RX=0
13400 RN(IS)=7+RZ
13500 IS=IS+10+RZ
13600 LL=LL+1
13700 PWDS(ITEM+LL)=IS
13800 C PUT IT IN THE PNTR ARRAY
13900 RZ=1.
14000 IF(IA.EQ.KSLA)RZ=0
14100 IF(L.LE.KN)GO TO 368
14200
14550 IF(KNT.GT.0)CALL SETLET
14575 C GOES TO SETLET AUTOMATICALLY IF MORE THAN ONE SLASH FOUND.
14600 IF(KFNT)IFNT=0
14700 KFNT=0
14710 INP(1)=0
14720 C SO IT WON'T FIND A COMMAND IN THE MAIN PROG.
14800 END
14900 C PACKS 4 CHARS/WD, 3 WDS/ITEM.
15000
15100 SUBROUTINE TYPE
15200 COMMON R2,JA,CENTR,J2,R3,R4,R5,RJQ(17),JQ(14),M,K,J,X,A,B
15300 COMMON/ALF/INP(72),ML
15400 TYPE 8005
15500 ACCEPT 2114,INP
15600 2114 FORMAT(72A1)
15700 8005 FORMAT(' TYPE --'/)
15800 CC** IF(JA.NE.16)CALL LNEND
15900 C FOR 'SCORE' INPUT
16000 END
16100
16200 SUBROUTINE SETLET
16300 COMMON/SCM/V(76),RR4,NN,Y,LCNT,STAFF,JLIST(200),REND
16350 C NOTE DIFFERENCE IN V ARRAY LNGTH 76+RR4+NN
16400 COMMON R2,JA,CENTR,J2,R3,R4,R5,RJQ(17),JQ(14),M,K,J,X,A,B
16500 1 /FLM/RPOS(2,300) /PTR/PWDS(250),ITEM,L,I,IX /XRN/RN(4000)
16600 COMMON/FRMT/F78F(1),FA1(1),FA5(1),KK /ALF/INP(72),ML
16610 COMMON/SCN/LEL,LR,LU,LD,KSLA,LE,LC,LS,LF,LA,LI,LW
16700 DIMENSION SU(320)
16800 COMMON/POSI/STF(-3/4),J102,POS/DPY/ST(4000),WDS(250),MEDIT,IGO
16900 EQUIVALENCE (J5,JQ(3)),(ISET,RJQ(9)),(SU(1),ST(3600))
17000 DATA DISP/0.0/
17100 KK=L
17200 C L=NUMBER OF ITEMS TYPED +1
17300 M=1
17310 IF(R4.EQ.0)KK=0
17320 C =0 ALWAYS WANTS PAIRS OF NUMS.
17350 RR4=R4
17375 C GIVEN VERTICAL POS.
17400 R4=20
17500 RPOS(1,1)=0
17600 DO 1 K=1,ITEM
17700 IF(FINDIT(K))GO TO 1
17800 C SKIPS NON-NOTES AND WRONG STAFF
17900 M=M+1
18000 RPOS(1,M)=RN(L+3)
18100 1 CONTINUE
18200 IF(M.EQ.1)RETURN
18300 C M=1 MEANS NO NOTES ON THIS LINE
18400 CXX CALL SETNUM
18500 CALL DPYSET(3,SU,320)
18600 CALL DPYBRT(6)
18700 CC R6=1
18800 POS=STF(J2)
18900 J5=1
19000 CALL SORT2(RPOS,M)
19100 K=2
19200 22 IF(IFIX(RPOS(1,K)*100.).NE.IFIX(RPOS(1,K-1)*100.))GO TO 2
19300 C ROUNDS OFF POSITION TO 2 DECI. PLACES
19400 M=M-1
19500 DO 20 J=K,M
19600 20 RPOS(1,J)=RPOS(1,J+1)
19700 C DELETES DOUBLE-STOPS - DOESN'T PUT NUM OVER 1ST NOTE.
19800 IF(M.LT.K)K=M
19900 GO TO 22
20000 302 FORMAT(17X'POS. FOR -- ',72A1/)
20200 2 K=K+1
20300 IF(K.LT.M)GO TO 22
20400 DO 4 K=2,M
20500 R3=RHORZ(RPOS(1,K))
20600 CALL PNUM
20700 J5=J5+1
20800 4 IF(J5.EQ.10)J5=0
20900 CALL DPYOUT(3)
21000 CALL SETPOG(1)
21100 RPOS(1,M+1)=200
21410 NN2=1
21500 J=1
21600 JJ=1
21700 IF(B)GO TO 30
21800 C B IS JR IN 'WORDS' NEXT FOR READIN FILES WITH WORDS
21900 READ(21,F78F)X,V
21950 NN=76
22000 GO TO 31
22100 CC30 CALL TYPE
22200 CC REREAD F78F,V
22210 C FLAG FOR ALL BLANKS AT END OF LINE
22250 30 MM=-1
22260 K=JJ
22400 300 IF(INP(K).NE.' ')MM=0
22500 IF(INP(K).EQ.KSLA)GO TO 301
22550 IF(K.EQ.72)GO TO 301
22575 K=K+1
22587 GO TO 300
22600 301 IF(MM)GO TO 31
22700 TYPE 302 ,(INP(LL),LL=JJ,K)
22800 NN=NN2
22850 NN2=NN2+1
22900 ACCEPT F78F,V(NN),V(NN2)
22950 IF(RR4.EQ.0)NN2=NN2+1
23000 V(NN2)=0
23100 JJ=K+1
23200 IF(K.LT.72)GO TO 30
23300
23400 31 X=V(J)+1
23500 DO 32 K=NN,1,-1
23600 32 IF(V(K).NE.0)GO TO 320
23700 320 IF(K.GT.KK)KK=-1
23800 C NOW PAIRS OF NUMS WILL SET INDIV. VERT. POS.; SINGLE DON'T
23900 3 K=X
24000 CC MM=ISET+4
24100 A=RPOS(1,K)
24200 B=RPOS(1,K+1)
24300 RN(ISET+3)=A+(B-A)*(X-K)+DISP
24400 C DISP IS DISPLACEMENT OF CURRENT LETTERS.
24500 CC IF(RN(MM).NE.0)GO TO 5
24600 IF(KK.GT.0)GO TO 5
24700 C NEXT FOR PAIRS OF NUMS.
24800 CC RN(MM)=V(J+1)
24900 RN(ISET+4)=V(J+1)
25000 J=J+2
25100 GO TO 6
25200 C IF P4≠0 TYPE ONLY 1 # FOR EACH ITEM. ALL ITEMS WILL BE AT VRT PS OF P4
25300 C TYPE Nn, Vert pos/Nn, Vert pos/ OR Nn/Nn/ (if P4≠0)
25400 5 J=J+1
25500 6 ISET=ISET+RN(ISET)+3
25600 IF(RN(ISET).EQ.8)GO TO 6
25700 C =8 MEANS MORE LETTERS TO COME.
25800 X=V(J)+1
25900 IF(X.GT.1)GO TO 3
26000 C CAN'T PUT LETTER AT POS. 0 *********
26100 END
26200
26300 CF SUBROUTINE NEWR
26400 CF COMMON/PTR/PWDS(250),ITEM,LL,IS,IX
26500 CF COMMON/XRN/RN(4000)
26600 CF COMMON/SCM/V(78),I,LCNT,STAFF,LIST(200),REND
26700 CF COMMON/SCX/RHY(4),JALPHA(22),JX,U,JZ,IRHY,J4,KA,KB,IZ
26800 CF 1 /SC/J,L,MK,ISKP,XMINUS,N,IEXP,LK,NNUM,JJ,JA,DBST,NFLG
26900 CF 1 ,IXX,ISEMI,IQT,VX(50),IAMP,K,KN,M,MODE,IBLA
27000 CF DIMENSION R(10,80)
27100 CF EQUIVALENCE (R,RN(3001))
27200
27300 CF IF(MODE.NE.1)GO TO 1
27400 CF IK=IS
27500 CF JIT=ITEM
27600 CF1 IS=IK
27700 CF ITEM=JIT+1
27800 C MODE 1=NOTE, 2=RHYTH, 3=ACCENTS, 4=BEAMS, 5=SLURS.
27900 CF DO 2 K=1,IZ
28000 CF IF(R(8,K).EQ.9999.)GO TO 2
28100 C SKIPS INVIS RESTS - ONLY NEEDED IN RHYTH.
28200 C JUMP FOR BEAM CONT.
28300 CF IEND=-1
28400 CF RN(IS+3)=0
28500 CF RN(IS+2)=0
28600 C ↑↑↑↑ TO CLEAR ARRAY FOR SHORT ITEMS (CLEFS)
28700 CF DO 3 L=9,1,-1
28800 CF A=R(L,K)
28900 CF IF(A.NE.0)GO TO 77
29000 CF IF(IEND)GO TO 3
29100 CF77 IF(IEND)IEND=L
29200 CF RN(IS+L)=A
29300 CF3 CONTINUE
29400 CF IF(IEND.LT.3)IEND=3
29500 CF CALL UPDATE(IEND-2)
29600 CF2 CONTINUE
29700 CF END
29800
29900 SUBROUTINE LNEND
30000 C CHANGES LINE ENDS SO INPUT CAN LOOK LIKE NEW 'SCORE' INPUT.
30100 COMMON /ALF/INP(1),ML
30200 COMMON/SCX/RHY(4),JALPHA(30),J4,L,Y,K,RX,RZ,RA,J5
30210 COMMON/SCN/LEL,LR,LU,LD,KSLA,LE,LC,LS,LF,LA,LI,LW
30300 EQUIVALENCE (ISEMI,JALPHA(10)),(ISTAR,JALPHA(8))
30400 DO 2902 L=72,1,-1
30500 IF(INP(L).NE.KSLA)GO TO 2903
30600 INP(L)=ISEMI
30700 RETURN
30800 2903 IF(INP(L).NE.ISEMI)GO TO 2902
30900 INP(L)=ISTAR
31000 RETURN
31100 2902 CONTINUE
31200 END
31300
31400
31500 C**** CHANGE 1, 2 AND 3 TO JFCL IN DDT WHEN USING DISTORTION.(SEE 'LINES')
31600 SUBROUTINE FILLMS(L,IDAT,R2,CENTR,R6,R7)
31700 COMMON/DPY/ST(4000),WDS(250),MEDIT,IGO/DL/RSIZ,SAVER,NAME
31800 COMMON/DST/BB,CC/FLM/X(600)
31900 COMMON/ALF/INP(65),DX,RX,D,R,C,KK,J,ML
32000 DIMENSION IDAT(1),NX(600)
32100 EQUIVALENCE (NX,X)
32200 COMMON/PLTR/IPLT,RHT,DIS/LL/LL/STF/RR(8),RSTJ2
32300 DATA MD/6/ , RHT/1.0/
32400 C MD=DISPLAY CHANGE XGP TO 1 IN DDT WHEN PLOTTING ON XGP!
32500 DX=DIS
32600 RX=RHT
32700 D=RSTJ2*R6
32800 R=RSTJ2*R7
32900 1 GO TO 10
33000 C=CC
33100 B=BB
33200 C SAVES IT. IT WILL RETURN LATER.
33300 BB=B/DIS
33400 CC=1000
33500 10 KK=-2
33600 DO 205 J=1,L
33700 CALL UNPACK(M,N,IDAT(J))
33800 KK=KK+3
33900 KX=KK+2
34000 NX(KX)=2
34100 IF(LL.EQ.3)NX(KX)=3
34200 X(KK)=ROFF((R2+D*M)*DIS)
34300 X(KK+1)=ROFF((CENTR+R*N)*RHT)
34400 2 GO TO 205
34500 X(KK+1)=X(KK+1)*(C-BB*(ABS(X(KK))))
34600 C FOR DISTORTION
34700 205 CONTINUE
34800 NX(3)=KX
34900 DIS=1.0
35000 RHT=DIS
35100 M=MD
35200 CC IF(IPLT)M=MP-IXRX
35300 IF(IPLT.GE.0)GO TO 20
35400 CC M=RSIZ+.4
35500 M=1
35600 IF(RSIZ.GE.2.)M=2
35700 CC IF(M.GT.XGP)M=XGP
35800 C STOPS DISTORTION IN 'LINES'
35900 20 CALL FILLER(X,M)
36000 C ****** CALLS NEW FILL.FAI (CLEM'S)
36100 DIS=DX
36200 RHT=RX
36300 3 RETURN
36400 C NEXT TO RESET DISTORTION FACT.
36500 BB=B
36600 CC=C
36700 END
36800
36900
37000 SUBROUTINE PRESCN
37100 C THIS SORTS OUT NEW INPUT FORMAT - CREATES OLD STYLE.
37200 COMMON/SCX/RHY(4),JALPHA(30),J4,L,Y,K,RX,RZ,RA,J5
37300 COMMON/SCN/LL,LR,LU,LD,LSL,LE,LC,LS,LF,LA,LI,LW
37400 DATA LL/'L'/,LR/'R'/,LU/'U'/,LD/'D'/,LE/'E'/,LSL/'/'/
37500 1,LC/'C'/,LS/'S'/,LF/'F'/,LA/'A'/,LI/'I'/,LW/'W'/
37600 DIMENSION IR(1)
37700 COMMON/ALF/INP(72),M/XRN/RN(4000)
37800 EQUIVALENCE (IR,RN(2001)),(LCM,JALPHA),(LBL,JALPHA(12))
37900 1,(LST,JALPHA(8)),(ISEMI,JALPHA(10)),(ICOL,JALPHA(9))
38000 1,(IDOT,JALPHA(3))
38100 C CHECK THIS EQUIV.↑↑↑↑
38200 100 IF(ISM)5,55,555
38300 C -1=PROCESS SOME MORE, 0=1ST TIME, 1=PUT OUT RHYTH
38400 C !!!!! DON'T STOP IN THE MIDDLE!!! ISM MUST BE 0 FIRST TIME!!!!
38500 55 JX=0
38600 5 K=0
38700 J=0
38800 I=JX
38900 JX=JX+72
39000 1 K=K+1
39100 M=INP(K)
39200 15 IF(M.EQ.LBL)GO TO 1
39300 IF(M.EQ.LCM)GO TO 1
39400 C REMOVE BLANKS AND COMMAS
39500 JN=0
39600 IF(M.LT.'0')GO TO 677
39700 IF(M.LE.'9')GO TO 2
39800 677 MM=INP(K+1)
39900 3 IF(M.EQ.'P')GO TO 8
40000 IF(M.EQ.'O')GO TO 8
40100 IF(M.LT.LA)GO TO 777
40200 IF(M.GT.'G')GO TO 777
40300 IF(MM.EQ.LL)GO TO 777
40400 IF(MM.NE.LA)GO TO 8
40500 C FINDS NOTES, PROX., AND ORDINARY, -- NOT 'BA' OR 'AL'
40600 777 IF(M.NE.LR)GO TO 9
40700 IF(MM.EQ.LE)JN=1
40800 C CATCHES 'R' 'RI' 'REP'
40900 GO TO 8
41000 9 IF(M.EQ.LSL)GO TO 8
41100 IF(M.EQ.ISEMI)GO TO 8
41200 IF(M.EQ.LST)GO TO 8
41300 IF(M.EQ.ICOL)GO TO 8
41400 JN=-1
41500 8 J=J+1
41600 INP(J)=M
41700 IF(M.EQ.'X')JN=1
41800 C PICKS UP 4X ETC. FOR BOTH NOTES AND RHYTH.
41900 IF(JN.LE.0)GO TO 13
42000 C PUTS 'REP' INTO RHYTH ALSO
42100 I=I+1
42200 IR(I)=M
42300 13 IF(M.EQ.LSL)GO TO 4
42400 IF(M.EQ.ISEMI)GO TO 4
42500 IF(M.EQ.LST)GO TO 4
42600 K=K+1
42700 M=INP(K)
42800 GO TO 8
42900
43000 4 IF(JN.NE.0)GO TO 7
43100 I=I+1
43200 IR(I)=M
43300 7 IF(M.EQ.LSL)GO TO 1
43400 IF(M.EQ.ISEMI)GO TO 11
43500 IF(M.EQ.LST)GO TO 6
43600
43700 2 I=I+1
43800 IR(I)=M
43900 K=K+1
44000 M=INP(K)
44100 IF(M.EQ.IDOT)GO TO 2
44200 IF(M.LT.'0')GO TO 15
44300 IF(M.LE.'9')GO TO 2
44400 C NO BLANK NEEDED AFTER RHYTH.( /4.AS3/8/ ETC.)
44500 GO TO 15
44600
44700 11 IF(IR(I).NE.ISEMI)IR(I)=ISEMI
44800 ISM=-1
44900 RETURN
45000 C WE'LL COME BACK FOR MORE.
45100
45200 6 IF(IR(I).NE.LST)IR(I)=LST
45300 JX=0
45400 ISM=1
45500 C AFTER THIS WE USE RHYTJ DATA.
45600 RETURN
45700
45800 555 DO 12 K=1,72
45900 M=IR(K+JX)
46000 INP(K)=M
46100 IF(M.EQ.ISEMI)GO TO 10
46200 C MORE THAN ONE LINE
46300 12 IF(M.EQ.LST)GO TO 14
46400 10 JX=JX+72
46500 C MOVE TO THE NEXT 'LINE'
46600 RETURN
46700 14 ISM=0
46800 END